home *** CD-ROM | disk | FTP | other *** search
/ Oh!X 2001 Spring / Oh!X 2001 Spring Special CD-ROM (Japan).7z / Oh!X 2001 Spring Special CD-ROM (Japan) (Track 1).bin / TCLTK / SEVEN / seven.tcl next >
Text File  |  2000-05-07  |  12KB  |  509 lines
  1. #
  2. # seven.tcl : 同じ高さにある足して７になるカードを取り除く
  3. #
  4. #             Copyright (C) 1999 by Makoto Hiroi
  5. #
  6. # 外部変数
  7. #   board()   : 盤面（データを格納）
  8. #               上位 4 ビットで色、下位 4 ビットで数字を表す
  9. #   number()  : テキスト ID を格納
  10. #   numstr()  : 表示する文字列
  11. #   color()   : 表示する色
  12. #   piece()   : 図形 ID を格納
  13. #   px,py     : 選択した数字の座標( -1 は未選択 )
  14. #   rest      : 残りの枚数
  15. #   play_flag : ゲームの状態
  16. #               0 : not play
  17. #               1 : play 
  18. #               2 : use search
  19. #               4 : 検索中
  20. #   buff1     : メッセージ表示用バッファ
  21. #   buff2     : 名前入力用バッファ
  22. #   id        : after コマンドが返す固有番号
  23. #   name()    : トップテン(1 - 10, 0 is dummy)
  24. #   date()
  25. #   score()
  26. #
  27.  
  28. # 色
  29. set color(0) red
  30. set color(1) blue
  31. set color(2) green
  32. set color(3) gold
  33. # ワイルドカード用
  34. set color(4) black
  35.  
  36. # 数字
  37. set numstr(0) ""
  38. set numstr(1) "１"
  39. set numstr(2) "２"
  40. set numstr(3) "３"
  41. set numstr(4) "４"
  42. set numstr(5) "５"
  43. set numstr(6) "６"
  44. # ワイルドカード（どの場所の数字も入れ替えることができる）
  45. set numstr(7) "？"
  46.  
  47. # 初期化
  48. set play_flag 0
  49.  
  50.  
  51. # ヘルプファイルの表示
  52. proc help {} {
  53.     global path_name
  54.     if {![winfo exist .t0]} {
  55.         toplevel .t0
  56.         wm title .t0 "Seven Help"
  57.         text .t0.text -yscrollcommand ".t0.scroll set"
  58.         scrollbar .t0.scroll -command ".t0.text yview"
  59.     pack .t0.scroll -side right -fill y
  60.     pack .t0.text -side left
  61.     # ファイルの読み込み
  62.     set f [open "$path_name/sevenhelp.txt" r]
  63.     while {![eof $f]} {
  64.         .t0.text insert end [read $f 1000]
  65.     }
  66.     close $f
  67.     }
  68. }
  69.  
  70. # スコアファイルリード
  71. proc read_score_file {} {
  72.     global score_file name date score
  73.     set i 1
  74.     if [file exists $score_file] {
  75.     # ファイルの読み込み
  76.     set f [open $score_file r]
  77.     while {[gets $f line] >= 0} {
  78.         set l [split $line "\t"]
  79.         set name($i)  [lindex $l 0]
  80.         set date($i)  [lindex $l 1]
  81.         set score($i) [lindex $l 2]
  82.         incr i
  83.     }
  84.     close $f
  85.     }
  86.     set now_date [clock seconds]
  87.     while {$i <= 10} {
  88.     set name($i) ""
  89.     set date($i) $now_date
  90.     # 5999 は 99:59 です
  91.     set score($i) 5999
  92.     incr i
  93.     }
  94. }
  95.  
  96. # スコアファイルライト
  97. proc write_score_file {} {
  98.     global score_file name date score
  99.     set f [open $score_file w]
  100.     for {set i 1} {$i <= 10} {incr i} {
  101.     puts $f [format "%s\t%d\t%d" $name($i) $date($i) $score($i)]
  102.     }
  103.     close $f
  104. }
  105.  
  106.  
  107. # ********** スコア表示 ********
  108.  
  109. # 秒数をスコアに変換
  110. proc change_seconds {s} {
  111.     return [format "%02d:%02d" [expr $s / 60] [expr $s % 60]]
  112. }
  113.  
  114. #
  115. # トップテンウィンドウを開く
  116. #
  117. proc open_score_window {ranking} {
  118.     global name date score
  119.     if [winfo exists .t1] {
  120.     destroy .t1
  121.     }
  122.     toplevel .t1
  123.     wm title .t1 "Top 10"
  124.     frame .t1.f0
  125.     frame .t1.f1
  126.     label .t1.f0.l0 -text "順位  名前" -anchor w
  127.     label .t1.f1.l0 -text "記録    日付  " -anchor w
  128.     pack .t1.f0.l0 -fill x
  129.     pack .t1.f1.l0 -fill x
  130.     for {set i 1} {$i <= 10} {incr i} {
  131.     label .t1.f0.l$i -text [format "%4d %-20s" $i $name($i)] -anchor w
  132.     label .t1.f1.l$i -text [format "%5s %8s" \
  133.                 [change_seconds $score($i)] \
  134.                 [clock format $date($i) -format "%y/%m/%d"]]
  135.     pack  .t1.f0.l$i -fill x
  136.     pack  .t1.f1.l$i -fill x
  137.     }
  138.     if {$ranking > 0} {
  139.     .t1.f0.l$ranking configure -fg red
  140.     .t1.f1.l$ranking configure -fg red
  141.     }
  142.     pack .t1.f0 .t1.f1 -side left
  143. }
  144.  
  145. # ベストテンに入るか
  146. proc check_hi_score {now_score} {
  147.     global score
  148.     for {set i 1} {$i <= 10} {incr i} {
  149.     if {$score($i) > $now_score} {
  150.         # ベストテンに入ったよ
  151.         return $i
  152.     }
  153.     }
  154.     return 0
  155. }
  156.  
  157. # スコアの更新
  158. proc update_score {n d s o} {
  159.     global name date score
  160.     for {set i 9} {$i >= $o} {incr i -1} {
  161.     set j [expr $i + 1]
  162.     set name($j) $name($i)
  163.     set date($j) $date($i)
  164.     set score($j) $score($i)
  165.     }
  166.     set name($o) $n
  167.     set date($o) $d
  168.     set score($o) $s
  169. }
  170.  
  171. # トップテンの名前入力
  172. proc input_hi_score_name {ranking} {
  173.     global buff2
  174.     set buff2 ""
  175.     toplevel .t2
  176.     wm title .t2 "Input Your Name"
  177.     wm geometry .t2 "+[expr [winfo x .] + 120]+[expr [winfo y .] + 180]"
  178.     label .t2.l0 -text [format "おめでとう！ %d 位です" $ranking]
  179.     label .t2.l1 -text "名前を入力してね"
  180.     entry .t2.e0 -textvariable buff2
  181.     focus -force .t2.e0
  182.     grab set -global .t2
  183.     bind .t2.e0 <Return> {
  184.     # 入力チェックが必要か
  185.     if {$buff2 != ""} {
  186.         destroy .t2
  187.     }
  188.     }
  189.     pack .t2.l0 .t2.l1 .t2.e0
  190. }
  191.  
  192. # 盤面から色を求める
  193. proc get_color {x y} {
  194.     global board
  195.     return [expr $board($x,$y) / 16]
  196. }
  197.  
  198. # 盤面から数字を求める
  199. proc get_number {x y} {
  200.     global board
  201.     return [expr $board($x,$y) % 16]
  202. }
  203.  
  204. # 終了チェック
  205. proc check_finish {} {
  206.     global board rest buff2 play_flag id time
  207.     if {$rest(normal) == 0} {
  208.     # 終了
  209.     set t [clock seconds]
  210.     set s [expr [clock seconds] - $time]
  211.     after cancel $id
  212.     set ranking [check_hi_score $s]
  213.     if {$ranking > 0 && $play_flag == 1} {
  214.         input_hi_score_name $ranking 
  215.         tkwait window .t2
  216.         update_score $buff2 $t $s $ranking
  217.         write_score_file
  218.         open_score_window $ranking
  219.     } else {
  220.         tk_messageBox -type ok \
  221.         -message [format "おめでとう %s です" [change_seconds $s]]
  222.     }
  223.     return 1
  224.     } elseif {[search_piece] == "" && $rest(wild) == 0} {
  225.     after cancel $id
  226.     tk_messageBox -type ok -message "手詰まりです"
  227.     return 1
  228.     }
  229.     return 0
  230. }
  231.  
  232. # 牌を取り除く
  233. proc remove_piece {x y} {
  234.     global board piece rest
  235.     # 色を元に戻す
  236.     .c0 itemconfigure $piece($x,$y) -fill white
  237.     # 下に落とすだけ
  238.     while {$y > 0} {
  239.     set y1 [expr $y - 1]
  240.     set board($x,$y) $board($x,$y1)
  241.     incr y -1
  242.     }
  243.     set board($x,0) 0
  244.     draw_board_line $x
  245. }
  246.  
  247. # 取れる牌を探す
  248. proc search_piece {} {
  249.     global board piece
  250.     set result ""
  251.     for {set y 0} {$y < 10} {incr y} {
  252.     for {set x 0} {$x < 8} {incr x} {
  253.         if {$board($x,$y) != 0} {
  254.         set i [expr $x + 1]
  255.         while {$i < 8} {
  256.             if {$board($i,$y) != 0} {
  257.             if {[get_color $x $y] == [get_color $i $y] && \
  258.                             [expr [get_number $x $y] + [get_number $i $y]] == 7} {
  259.                 set result [concat $result $piece($x,$y) $piece($i,$y)]
  260.             }
  261.             }
  262.             incr i
  263.         }
  264.         }
  265.     }
  266.     }
  267.     return $result
  268. }
  269.  
  270. # 検索
  271. proc search {} {
  272.     global play_flag px py
  273.     if {!($play_flag & 0x03)} return
  274.     if {$px != -1} {
  275.     # 選択していたらキャンセルして表示する
  276.     push_piece $px $py
  277.     }
  278.     set play_flag 4
  279.     set pieces [search_piece]
  280.     set len [llength $pieces]
  281.     set i 0
  282.     while {$i < $len} {
  283.     set p1 [lindex $pieces $i]
  284.     incr i
  285.     set p2 [lindex $pieces $i]
  286.     incr i
  287.     .c0 itemconfigur $p1 -fill darkgray
  288.     .c0 itemconfigur $p2 -fill darkgray
  289.     update
  290.     after 500
  291.     .c0 itemconfigur $p1 -fill white
  292.     .c0 itemconfigur $p2 -fill white
  293.     }
  294.     set play_flag 2
  295. }
  296.  
  297. # カードの交換
  298. proc change_card {x y} {
  299.     global px py piece board rest time
  300.     if {[get_number $x $y] != 7} {
  301.     .c0 itemconfigure $piece($x,$y) -fill darkgray
  302.     update
  303.     after 250
  304.     # ワイルドカードに挿入
  305.     set board($px,$py) $board($x,$y)
  306.     .c0 itemconfigure $piece($px,$py) -fill white
  307.     draw_board_line $px
  308.     # 移動したカードを消去
  309.     remove_piece $x $y
  310.     incr rest(wild) -1
  311.     # 10 秒加算する
  312.     incr time -10
  313.     set px -1
  314.     set py -1
  315.     }
  316. }
  317.  
  318. # 数字を押したよ
  319. proc push_piece {x y} {
  320.     global play_flag px py piece id rest
  321.     if {!($play_flag & 0x03)} return
  322.     if {$px == $x && $py == $y} {
  323.     # 同じ数字を押したらキャンセル
  324.     set px -1
  325.     set py -1
  326.     .c0 itemconfigure $piece($x,$y) -fill white
  327.     } elseif {$px == -1} {
  328.     # 最初の選択
  329.     set px $x
  330.     set py $y
  331.     .c0 itemconfigure $piece($x,$y) -fill darkgray
  332.     } else {
  333.     # ２回目
  334.     if {$py == $y && [get_color $px $py] == [get_color $x $y] && \
  335.                          [expr [get_number $px $py] + [get_number $x $y]] == 7} {
  336.         # 消せるよ
  337.         .c0 itemconfigure $piece($x,$y) -fill darkgray
  338.         update
  339.         after 250
  340.         # 上にある牌から消去する
  341.         if {$py > $y} {
  342.         remove_piece $x $y
  343.         remove_piece $px $py
  344.         } else {
  345.         remove_piece $px $py
  346.         remove_piece $x $y
  347.         }
  348.         incr rest(normal) -2
  349.         set px -1
  350.         set py -1
  351.     } elseif {[get_number $px $py] == 7} {
  352.         # カードの交換
  353.         change_card $x $y
  354.     }
  355.     # 手詰まりチェック
  356.     if [check_finish] {
  357.         set play_flag 0
  358.     }
  359.     }
  360. }
  361.  
  362. # ********** 初期化ルーチン **********
  363.  
  364. # 盤面の初期化
  365. proc make_board {} {
  366.     global board
  367.     # piece_table は局所変数
  368.     for {set i 0; set c 0} {$c < 4} {incr c} {
  369.     for {set n 1} {$n <= 6} {incr n} {
  370.         # piece_tabale の初期化
  371.         for {set j 0} {$j < 3} {incr j} {
  372.         set piece_table($i) [expr $c * 16 + $n]
  373.         incr i
  374.         }
  375.     }
  376.     }
  377.     # ワイルドカードのセット
  378.     for {set c 0} {$c < 8} {incr c} {
  379.         # 4 * 16 + 7 = 71
  380.         set piece_table($i) 71
  381.         incr i
  382.     }
  383.     # 乱数でかき回す
  384.     for {set j 0} {$j < $i} {incr j} {
  385.     set n    [expr int( rand() * $i )]
  386.     set temp $piece_table($n)
  387.     set piece_table($n) $piece_table($j)
  388.     set piece_table($j) $temp
  389.     }
  390.     # board にセット
  391.     set i 0
  392.     for {set y 0} {$y < 10} {incr y} {
  393.     for {set x 0} {$x < 8} {incr x} {
  394.         set board($x,$y) $piece_table($i)
  395.         incr i
  396.     }
  397.     }
  398. }
  399.  
  400.  
  401. # 縦の１列を描く
  402. proc draw_board_line {x} {
  403.     global piece number numstr color
  404.     for {set y 0} {$y < 10} {incr y} {
  405.     set c [get_color $x $y]
  406.     set n [get_number $x $y]
  407.     if {$n != 0} {
  408.         .c0 itemconfigure $number($x,$y) -text $numstr($n) -fill $color($c)
  409.         .c0 raise $piece($x,$y)
  410.         .c0 raise $number($x,$y)
  411.     } else {
  412.         .c0 lower $piece($x,$y)
  413.         .c0 lower $number($x,$y)
  414.     }
  415.     }
  416. }
  417.  
  418. # 全体を表示する
  419. proc draw_board {} {
  420.     for {set x 0} {$x < 8} {incr x} {
  421.     draw_board_line $x
  422.     }
  423. }
  424.  
  425. # メッセージの表示
  426. proc display_message {} {
  427.     global time buff1
  428.     set t [expr [clock seconds] - $time]
  429.     set buff1 [format "時間 %5s" [change_seconds $t]]
  430. }
  431.  
  432. # 時間の表示
  433. proc display_time {} {
  434.     global id
  435.     display_message
  436.     set id [after 1000 display_time]
  437. }
  438.  
  439. # ゲームの開始
  440. proc start_game {} {
  441.     global play_flag rest px py id time
  442.     if {$play_flag > 0} {
  443.     after cancel $id
  444.     }
  445.     make_board
  446.     draw_board
  447.     set rest(normal) 72
  448.     set rest(wild)   8
  449.     set play_flag 1
  450.     set px -1
  451.     set py -1
  452.     set time [clock seconds]
  453.     display_time
  454. }
  455.  
  456. # ********** メニューの設定 **********
  457. menu .m -type menubar
  458. . configure -menu .m
  459. .m add cascade -label "Games"    -under 0 -menu .m.m1
  460. .m add command -label "Search"   -under 0 -command "search"
  461. .m add command -label "Help"     -under 0 -command "help"
  462. menu .m.m1 -tearoff no
  463. .m.m1 add command -label "Start"   -under 0 -command "start_game"
  464. .m.m1 add command -label "HiScore" -under 0 -command "open_score_window 0"
  465. .m.m1 add separator
  466. .m.m1 add command -label "Exit" -under 0 -command "exit"
  467.  
  468. # オプションの設定
  469. option add *font "{ＭＳ ゴシック} 12"
  470.  
  471. # **********画面の生成 **********
  472. canvas .c0 -width 272 -height 340
  473. # 背景
  474. .c0 create rectangle 0 0 271 339 -fill darkgreen
  475. for {set y 0} {$y < 10} {incr y} {
  476.     for {set x 0} {$x < 8} {incr x} {
  477.     set x1 [expr $x * 34]
  478.     set x2 [expr $x1 + 33]
  479.     set y1 [expr $y * 34]
  480.     set y2 [expr $y1 + 33]
  481.     set piece($x,$y) [.c0 create rectangle $x1 $y1 $x2 $y2 -fill white]
  482.     set number($x,$y) [.c0 create text [expr $x1 + 17] [expr $y1 + 17] \
  483.          -text " " \
  484.                  -font "{ＭＳ ゴシック} 24"]
  485.     .c0 bind $piece($x,$y)  <Button-1> "push_piece $x $y"
  486.     .c0 bind $number($x,$y) <Button-1> "push_piece $x $y"
  487.     }
  488. }
  489.  
  490. # 表示用ラベル
  491. label .l1 -textvariable buff1 -bg darkgreen -fg white -anchor e
  492.  
  493. pack .l1 .c0 -fill x
  494.  
  495. # 窓の題名
  496. wm title . "Seven"
  497. wm resizable . 0 0
  498.  
  499. # 初期化
  500. set path_name [file dirname $argv0]
  501. set score_file "$path_name/SEVEN.SCO"
  502. expr srand( [clock seconds] )
  503.  
  504. # スコアファイルのリード
  505. read_score_file
  506. focus -force .
  507.  
  508. # end of file
  509.